home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Internet Tools 1995 April / Internet Tools.iso / mail / listserv / utils / list_stats.pl.Z / list_stats.pl
Encoding:
Perl Script  |  1994-05-04  |  6.0 KB  |  214 lines
  1. #!/usr/public/bin/perl
  2. #
  3. # From: Carl Paukstis <carlp@onpmomma.isc-br.com>
  4. #
  5. # Here's a PERL script I wrote to generate some statistics by subscriber
  6. # for some of my mailing lists.  Feel free to improve it (send me
  7. # improvements please) and/or hack it to better meet your needs.
  8. #
  9. # Gather ListProcessor mailing list statistics by subscriber from archive file.
  10. # Statistics are for one month, specified on the command-line.  The script
  11. # implicity assumes (and handles) "permissive" list mode, where messages are
  12. # not necessarily from addresses which can be found in the .subscribers file.
  13. #
  14. # Usage: stats.pl listname mont
  15. #
  16. #  Written December, 1993 by Carl Paukstis  carlp@mail.spk.olivetti.com
  17. #
  18. #  Released to the public domain.  Please credit the author.
  19. #  The author does NOT consider himself a PERL wizard, please send
  20. #  suggestions to the address above.
  21. #
  22. #  NOTE: created with 4-column tabs!
  23. #
  24. # This script has been tested with Unix ListProcessor v6.0b. running on
  25. # Olivetti Unix SysVr4 with mail handled by smail v3.  There may be
  26. # dependencies on mail-header formats which are peculiar to smail.
  27. # 
  28. # Created and tested with Perl 4.0.1.8 patchlevel 36
  29. #
  30. eval "exec /usr/public/bin/perl -S $0 $*"
  31.     if $running_under_some_shell;
  32.  
  33. chdir("/home/listproc") || die "can't change to listproc home dir; stopped";
  34.  
  35. @monames = ("Jan","Feb","Mar","Apr","May","Jun",
  36.             "Jul","Aug","Sep","Oct","Nov","Dec");
  37. $err=0;
  38. if (@ARGV == 2) {
  39.     $listname = $ARGV[0];
  40.     $listname =~ tr/[a-z]/[A-Z]/;            # uppercase listname
  41.     $month = $ARGV[1];
  42.     if ($month =~ /^[0-9]+$/)                 # convert month number to name
  43.         { $month = $monames[$month - 1]; }
  44.     substr($month,3,99) = "";                # make month 3-char string
  45.     substr($month,0,1) =~ tr/[a-z]/[A-Z]/;    # first char uppercase
  46.     substr($month,1,2) =~ tr/[A-Z]/[a-z]/;    # remaining chars lowercase
  47. } else { 
  48.     ++$err; }
  49. if (! -d "lists/$listname") { ++$err; }        # list-directory absent?
  50.  
  51. ++$err;                                        # "prime" error-counter...
  52. foreach $mon(@monames) {
  53.     $month eq $mon && --$err;                # ...then undo if month is valid
  54. }
  55. if ($err) {
  56.     print "Usage: stats.pl list-name month\n";
  57.     exit 2;
  58. }
  59.  
  60. #
  61. #  Change the following to control input and output files.
  62. #
  63. $sub="lists/$listname/.subscribers";
  64. $ali="lists/$listname/.aliases";
  65. $mbox="lists/$listname/archive";
  66. $destfile="|sort -n >/tmp/stats.$listname";
  67.  
  68. #
  69. #  Build assoc-arrays for all subscribers
  70. #
  71. open(SUB,$sub) || die "Can't open $sub, stopped";
  72. while(<SUB>) {
  73.     chop;
  74.     ($addr,$mode,$pw,$conceal,$name) = split(/[\t\n ]+/,$_,5);
  75. #    printf("'%s' %9s %-37s\n",$addr,$mode,$name);
  76.     $bytes{$addr} = 0;
  77.     $lines{$addr} = 0;
  78.     $msgs{$addr} = 0;
  79.     $flag{$addr} = 1;
  80.     $names{$addr} = $name;
  81. }
  82. close(SUB);
  83. #
  84. #  Point aliased subscribers to the "real" address
  85. #
  86. open(ALI,$ali) || die "Can't open $ali, stopped";
  87. while(<ALI>) {
  88.     chop;
  89.     ($addr,$alias) = split(/[\t\n ]+/,$_,2);
  90.     if ($flag{$alias} != 1) {
  91.         print "No match for alias $alias\n";
  92.     }
  93.     $flag{$addr} = 2;
  94.     $aliases{$addr} = $alias;
  95. #    printf("'%s' (alias %s) = %s\n",$addr,$alias,$names{$alias});
  96. }
  97. close(ALI);
  98.  
  99. #
  100. #  Spin through message archive; collect stats fo each sending address.
  101. #
  102. $new = 0;
  103. $skipped = 0;
  104. open(MBOX,$mbox) || die "Can't open $mbox, stopped";
  105. while(<MBOX>) {
  106.     if (/^From /) {                 # new mail-message
  107.         $new = 1;
  108.         ++$totmsgs;
  109.         chop;
  110.         ($first, $addr, $weekday, $msgmonth, $rest) = split(/[\t\n ]+/,$_,5);
  111.         $addr =~ tr/a-z/A-Z/;
  112.         if($addr=~/.*DAEMON.*/ || $addr=~/.*UUCP.*/ || $msgmonth ne $month) {
  113.             ++$skipped;                # ignore bogus senders
  114.             while(<MBOX>) {
  115.                 last if (/^From /);
  116.                 }
  117.             redo;
  118.         }
  119.         if($flag{$addr} == 0) {
  120.             $flag{$addr} = 3;        # unknown addr; get info from "From:" line
  121.         }
  122.         if($flag{$addr} == 2) {        # aliased user; use alias for data-collect
  123.             $addr = $aliases{$addr};
  124.         }
  125.         ++$msgs{$addr};
  126. #        printf("'%s' %4d\n",($names{$addr}) ? $names{$addr} : $addr,$msgs{$addr});
  127.     }
  128.     elsif (/^From: / && $flag{$addr} == 3) {    # for non-subscribers
  129.         $flag{$addr} = 1;
  130.         chop;
  131.         s/From:\s+//;                    # strip front of line
  132.         s/\s+$//;                        # and training whitespace
  133.         $line = $_;
  134.         if (/\((.*)\)/) {                # From: user@node (name here)
  135. #            print "matched parens\n";
  136.             $name = $1;
  137.         }
  138.         elsif (/<(.*)>/) {                # From: "name here" <user@node>
  139. #            print "matched anglebrackets\n";
  140.             s/\s*<.*$//;
  141.             s/"//g;
  142.             $name = $_;
  143.         }
  144.         else {
  145.             $name = "-no name given-";
  146.         }
  147.         $bytes{$addr} = 0;
  148.         $lines{$addr} = 0;
  149.         $msgs{$addr} = 1;
  150.         $flag{$addr} = 1;
  151.         $names{$addr} = $name;
  152.         print "No sub '$addr' ($name)\n";
  153.     }
  154.     elsif (/^\s*$/ && $new == 1) {    # first blank line after "From " 
  155.         $new = 0;
  156.     }
  157.     elsif ($new == 0) {                # body of message
  158.         ++$lines{$addr};
  159.         $bytes{$addr} += length;
  160.     }
  161.         
  162. }
  163. close(MBOX);
  164. print "Total messages $totmsgs; skipped $skipped extraneous messages\n";
  165. #
  166. #  Output the report from the statistics arrays.
  167. #  A couple of compromises were made in the formats to assure that the
  168. #  output could be fed to 'sort -n' and come out looking decent.
  169. #
  170. open(REPORT,"$destfile");
  171. select(REPORT);
  172. $^="RT";
  173. $|=1;
  174. $= =999999;
  175. $totmsgs = 0;
  176. $totbytes = 0;
  177. $totlines = 0;
  178.  
  179. foreach $addr(keys(%msgs)) {
  180.     if ($msgs{$addr}) {                    # do only subscribers with >0 messages
  181.         write;
  182.         $totmsgs += $msgs{$addr};
  183.         $totbytes += $bytes{$addr};
  184.         $totlines += $lines{$addr};
  185.     }
  186. }
  187. $addr = "----------";
  188. $names{$addr} ="<--- TOTAL";
  189. $msgs{$addr} = $totmsgs;
  190. $lines{$addr} = $totlines;
  191. $bytes{$addr} = $totbytes;
  192. write;
  193.  
  194. # This is the end of the actual program.
  195.  
  196. format RT =
  197. -                Statistics for @||||||||| for @<<
  198.                                 $listname,     $month
  199. -Msgs  Lines  Bytes        Sender                     Address
  200. . 
  201.  
  202.  
  203. format REPORT =
  204. @>>>> @>>>>> @>>>>>  @<<<<<<<<<<<<<<<<<<<<<<<<<< @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
  205. $msgs{$addr},$lines{$addr},$bytes{$addr},($names{$addr}) ? $names{$addr}:$addr, $addr
  206. . 
  207. ----------------------------- cut here -------------------------------
  208. -- 
  209. Carl Paukstis, RRR&RSG   DoD#0432 1KQSPI=8.80   carlp@mail.spk.olivetti.com
  210. Olivetti North America                          carlp@mom.isc-br.com
  211. (Oli North): will deny responsibility    voice: (509) 927-5439 0700-1600 M-F
  212. Spokane, Washington, USA                   FAX: (509) 927-2499 24 hrs.
  213.  
  214.